;;; -*- Mode:LISP; Package:SI; Cold-Load:T; Base:8; Readtable:ZL -*-

(defun print-symbol (symbol stream &optional (rdtbl (current-readtable)))
  (let ((cp (current-package t))
        (sym-pkg (symbol-package symbol))
        (sym-name (symbol-name symbol))
        tem)
    (when *print-escape*
      (flet ((pp (pkg internal &aux tem PACKAGE-NAME PREFIX-NAME)
               (IF (PACKAGES::PACKAGE-REP-P PKG)
                   (SETQ PACKAGE-NAME (PACKAGES::PACKAGE-REP-NAME PKG)
                         PREFIX-NAME  (PACKAGES::PACKAGE-REP-NAME PKG))
                   (SETQ PACKAGE-NAME (PKG-NAME PKG)
                         PREFIX-NAME  (PKG-PREFIX-PRINT-NAME PKG)))
               (setq internal (if (memq internal '(:external :inherited))
                                  (pttbl-package-prefix rdtbl)
                                  (pttbl-package-internal-prefix rdtbl)))
               (block pp
                 (when (setq tem PREFIX-NAME)
                   (setq tem (assoc-equal tem (si:pkg-refname-alist cp)))
                   (when (or (null tem)
                             (eq (cdr tem) pkg))
                     (print-symbol-name PREFIX-NAME stream rdtbl)
                     (send stream :string-out internal)
                     (return-from pp)))
                 (setq tem (assoc-equal PACKAGE-NAME (si:pkg-refname-alist cp)))
                 (when (or (null tem)
                           (eq (cdr tem) pkg))
                   (print-symbol-name PACKAGE-NAME stream rdtbl)
                   (send stream :string-out internal)
                   (return-from pp))
                 ;; what a horrible piece of design that there is not pkg-name-and-nicknames
                 (dolist (n (pkg-nicknames pkg))
                   (setq tem (assoc-equal n (si:pkg-refname-alist cp)))
                   (when (or (null tem)
                             (eq (cdr tem) pkg))
                     (print-symbol-name n stream rdtbl)
                     (send stream :string-out internal)
                     (return-from pp)))
                 (print-symbol-name PACKAGE-NAME stream rdtbl)
                 (send stream :string-out "#:"))
               nil)
             (pg ()
                (and *print-gensym*
                     (send stream :string-out (pttbl-uninterned-symbol-prefix rdtbl)))))
        (cond ((null sym-pkg)
               (if (or (null cp)
                       (multiple-value-bind (found foundp)
                           (find-symbol sym-name cp)
                         (or (not foundp)
                             (not (eq found symbol)))))
                   (pg)))
              ((eq sym-pkg pkg-keyword-package)
               (send stream :tyo #/:))
              ;; people bind *package* nil expecting to have symbol home package printed
              ((null cp)
               (multiple-value-bind (nil foundp xp)
                   (find-symbol sym-name sym-pkg)
                 (if (null xp)
                     (pg)
                   (print-symbol-name (or (pkg-prefix-print-name xp) (pkg-name xp))
                                      stream rdtbl)
                   (send stream :string-out (if (memq foundp '(:external :inherited))
                                                (pttbl-package-prefix rdtbl)
                                              (pttbl-package-internal-prefix rdtbl))))))
              ((PACKAGES::PACKAGE-REP-P SYM-PKG)
               (PP SYM-PKG T))
              (t
               (multiple-value-bind (found foundp xp)
                   (find-symbol sym-name cp)
                 (cond ((not foundp)
                        (multiple-value-setq (nil foundp)
                          (find-symbol sym-name sym-pkg))
                        (pp sym-pkg foundp))
                       ((eq found symbol)
                        (when (assq symbol (rdtbl-symbol-substitutions rdtbl))
                          (pp xp foundp)))
                       (t
                        (unless (and (setq tem (assq found (rdtbl-symbol-substitutions rdtbl)))
                                     (eq (cdr tem) symbol))
                          (multiple-value-setq (nil foundp)
                            (find-symbol sym-name sym-pkg))
                          (pp sym-pkg foundp)))))))))
    (print-symbol-name sym-name stream rdtbl)))
